home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / proctool.cls < prev    next >
Text File  |  1997-06-14  |  5KB  |  151 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GProcTool"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EErrorProcTool
  13.     eeBaseProcTool = 13570  ' ProcTool
  14. End Enum
  15.  
  16. Function TopWndFromProcID(idProcA As Long) As Long
  17.     Dim idProc As Long, hWnd As Long
  18.     
  19.     ' Get first window
  20.     hWnd = GetWindow(GetDesktopWindow(), GW_CHILD)
  21.     Do While hWnd <> hNull
  22.         ' Check instance until it matches
  23.         Dim sTitle As String
  24.         sTitle = MWinTool.WindowTextLineFromWnd(hWnd)
  25.         idProc = MWinTool.ProcIDFromWnd(hWnd)
  26.         If idProcA = idProc Then
  27.             If MWinTool.IsVisibleTopWnd(hWnd) Then Exit Do
  28.         End If
  29.  
  30.         ' Get next sibling
  31.         hWnd = GetWindow(hWnd, GW_HWNDNEXT)
  32.     Loop
  33.     TopWndFromProcID = hWnd
  34. End Function
  35.     
  36. Public Function GetProcInfo(ByVal ID As Long, Optional TabStop As Integer = 0) As String
  37.     Dim sStart As String, s As String, sTemp As String
  38.     
  39.     ' Nested starting position
  40.     sStart = Space$(TabStop * 4)
  41.     ' Module information
  42.     s = sStart & "Program: " & MModTool.ExeNameFromProcID(ID) & sCrLf
  43.     s = s & sStart & "Module: " & Hex$(MModTool.ModFromProcID(ID)) & sCrLf
  44.     s = s & sStart & "Instance: " & Hex$(MModTool.InstFromProcID(ID)) & sCrLf
  45.     s = s & sStart & "PID: " & ID & sCrLf
  46.  
  47.     GetProcInfo = s
  48. End Function
  49.  
  50. ' Pass idProg returned by Shell or ShellPlus
  51. Function IsRunning(ByVal idProg As Long, _
  52.                    Optional ExitCode As Long) As Boolean
  53.     Static hProg As Long
  54.     ' Get process handle first time through and save it
  55.     If hProg = hNull Then
  56.         hProg = OpenProcess(PROCESS_QUERY_INFORMATION, False, idProg)
  57.     End If
  58.     If hProg = hNull Then
  59.         ' Invalid idProc because program completed before first call
  60.         ExitCode = 0
  61.     Else
  62.         ' Got a valid handle so use it to check process status
  63.         GetExitCodeProcess hProg, ExitCode
  64.     End If
  65.     If ExitCode = STILL_ACTIVE Then
  66.         IsRunning = True
  67.     Else
  68.         CloseHandle hProg
  69.     End If
  70. End Function
  71.  
  72. Function WaitOnProgram(ByVal idProg As Long, _
  73.                        Optional ByVal WaitDead As Boolean) As Long
  74.     Dim cRead As Long, iExit As Long, hProg As Long
  75.     ' Get process handle
  76.     hProg = OpenProcess(PROCESS_ALL_ACCESS, False, idProg)
  77.     If WaitDead Then
  78.         ' Stop dead until process terminates
  79.         Dim iResult As Long
  80.         iResult = WaitForSingleObject(hProg, INFINITE)
  81.         If iResult = WAIT_FAILED Then ErrRaise Err.LastDllError
  82.         ' Get the return value
  83.         GetExitCodeProcess hProg, iExit
  84.     Else
  85.         ' Get the return value
  86.         GetExitCodeProcess hProg, iExit
  87.         ' Wait, but allow painting and other processing
  88.         Do While iExit = STILL_ACTIVE
  89.             DoEvents
  90.             GetExitCodeProcess hProg, iExit
  91.         Loop
  92.     End If
  93.     CloseHandle hProg
  94.     WaitOnProgram = iExit
  95. End Function
  96.  
  97. ' Combine foreground and background console color attributes
  98. Function ColorAttr(ByVal atrFore As Byte, ByVal atrBack As Byte) As Long
  99.     ColorAttr = MBytes.LShiftWord((&HF And atrBack), 4) Or (&HF And atrFore)
  100. End Function
  101.  
  102. Function VBShellExecute(sFile As String, _
  103.                         Optional Args As String, _
  104.                         Optional Show As Long = vbNormalFocus, _
  105.                         Optional InitDir As String, _
  106.                         Optional Verb As String, _
  107.                         Optional hWnd As Long = hNull) As Long
  108.     Dim ID As Long
  109.     ID = ShellExecute(hWnd, Verb, sFile, Args, InitDir, Show)
  110.     ' Translate weird ShellExecute errors into normal errors
  111.     Select Case ID
  112.     Case 0
  113.         ID = ERROR_NOT_ENOUGH_MEMORY
  114.     Case SE_ERR_SHARE                                       ' 26
  115.         ID = ERROR_SHARING_VIOLATION
  116.     Case SE_ERR_ASSOCINCOMPLETE                             ' 27
  117.         ID = ERROR_NO_ASSOCIATION
  118.     Case SE_ERR_DDETIMEOUT, SE_ERR_DDEFAIL, SE_ERR_DDEBUSY  ' 28, 29, 30
  119.         ID = ERROR_DDE_FAIL
  120.     Case SE_ERR_NOASSOC                                     ' 31
  121.         ID = ERROR_NO_ASSOCIATION
  122.     Case SE_ERR_DLLNOTFOUND                                 ' 32
  123.         ID = ERROR_DLL_NOT_FOUND
  124.     Case Is > 32
  125.         VBShellExecute = ID
  126.         Exit Function
  127.     End Select
  128.     ApiRaise ID
  129. End Function
  130.  
  131. #If fComponent = 0 Then
  132. Private Sub ErrRaise(e As Long)
  133.     Dim sText As String, sSource As String
  134.     If e > 1000 Then
  135.         sSource = App.ExeName & ".ProcTool"
  136.         Select Case e
  137.         Case eeBaseProcTool
  138.             BugAssert True
  139.        ' Case ee...
  140.        '     Add additional errors
  141.         End Select
  142.         Err.Raise COMError(e), sSource, sText
  143.     Else
  144.         ' Raise standard Visual Basic error
  145.         sSource = App.ExeName & ".VBError"
  146.         Err.Raise e, sSource
  147.     End If
  148. End Sub
  149. #End If
  150.  
  151.